home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / programm.ing / m2posx10.zoo / m2posix.10 / src / cstr.ipp < prev    next >
Encoding:
Modula Implementation  |  1993-09-24  |  12.9 KB  |  571 lines
  1. IMPLEMENTATION MODULE cstr;
  2. __IMP_SWITCHES__
  3. #ifdef HM2
  4. #ifdef __LONG_WHOLE__
  5. (*$!i+: Modul muss mit $i- uebersetzt werden! *)
  6. (*$!w+: Modul muss mit $w- uebersetzt werden! *)
  7. #else
  8. (*$!i-: Modul muss mit $i+ uebersetzt werden! *)
  9. (*$!w-: Modul muss mit $w+ uebersetzt werden! *)
  10. #endif
  11. #endif
  12. (*****************************************************************************)
  13. (* 18-Sep-93, Holger Kleinschmidt                                            *)
  14. (*****************************************************************************)
  15.  
  16. VAL_INTRINSIC
  17. CAST_IMPORT
  18.  
  19. FROM SYSTEM IMPORT
  20. (* PROC *) ADR;
  21.  
  22. FROM PORTAB IMPORT
  23. (* CONST*) NULL,
  24. (* TYPE *) UNSIGNEDWORD, SIGNEDWORD;
  25.  
  26. IMPORT e;
  27.  
  28. FROM types IMPORT
  29. (* CONST*) EOS,
  30. (* TYPE *) sizeT, StrPtr, StrRange;
  31.  
  32. (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
  33.  
  34. VAR
  35.   null  : CHAR;
  36.   nullP : StrPtr;
  37.  
  38. (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
  39.  
  40. PROCEDURE strlen ((* EIN/ -- *) strC : StrPtr ): sizeT;
  41. (*T*)
  42. VAR __REG__ len : StrRange;
  43.     __REG__ ptr : StrPtr;
  44.  
  45. BEGIN
  46.  ptr := strC;
  47.  IF ptr = NULL THEN
  48.    RETURN(0);
  49.  END;
  50.  len := 0;
  51.  WHILE ptr^[len] <> 0C DO
  52.    INC(len);
  53.  END;
  54.  RETURN(VAL(sizeT,len));
  55. END strlen;
  56.  
  57. (*---------------------------------------------------------------------------*)
  58.  
  59. PROCEDURE strcpy ((* EIN/ -- *) dst : StrPtr;
  60.                   (* EIN/ -- *) src : StrPtr );
  61. (*T*)
  62. VAR __REG__ idx : StrRange;
  63.     __REG__ c   : CHAR;
  64.     __REG__ d   : StrPtr;
  65.     __REG__ s   : StrPtr;
  66.  
  67. BEGIN
  68.  d := dst;
  69.  s := src;
  70.  IF d = NULL THEN
  71.    RETURN;
  72.  ELSIF s = NULL THEN
  73.    s := nullP;
  74.  END;
  75.  idx := 0;
  76.  REPEAT
  77.    c := s^[idx];
  78.    d^[idx] := c;
  79.    INC(idx);
  80.  UNTIL c = 0C;
  81. END strcpy;
  82.  
  83. (*---------------------------------------------------------------------------*)
  84.  
  85. PROCEDURE strncpy ((* EIN/ -- *) dst : StrPtr;
  86.                    (* EIN/ -- *) src : StrPtr;
  87.                    (* EIN/ -- *) len : sizeT  );
  88. (*T*)
  89. VAR __REG__ idx : StrRange;
  90.     __REG__ c   : CHAR;
  91.     __REG__ d   : StrPtr;
  92.     __REG__ s   : StrPtr;
  93.     __REG__ l   : StrRange;
  94.  
  95. BEGIN
  96.  d := dst;
  97.  s := src;
  98.  l := VAL(StrRange,len);
  99.  IF (d = NULL) OR (l = 0) THEN
  100.    RETURN;
  101.  ELSIF s = NULL THEN
  102.    s := nullP;
  103.  END;
  104.  idx := 0;
  105.  REPEAT
  106.    c := s^[idx];
  107.    d^[idx] := c;
  108.    INC(idx);
  109.    DEC(l);
  110.  UNTIL (c = 0C) OR (l = 0);
  111.  WHILE l > 0 DO
  112.    d^[idx] := 0C;
  113.    INC(idx);
  114.    DEC(l);
  115.  END;
  116. END strncpy;
  117.  
  118. (*---------------------------------------------------------------------------*)
  119.  
  120. PROCEDURE strcat ((* EIN/ -- *) dst : StrPtr;
  121.                   (* EIN/ -- *) src : StrPtr );
  122. (*T*)
  123. VAR __REG__ dIdx : StrRange;
  124.     __REG__ sIdx : StrRange;
  125.     __REG__ c    : CHAR;
  126.     __REG__ d    : StrPtr;
  127.     __REG__ s    : StrPtr;
  128.  
  129. BEGIN
  130.  d := dst;
  131.  s := src;
  132.  IF (d = NULL) OR (s = NULL) THEN
  133.    RETURN;
  134.  END;
  135.  dIdx := 0;
  136.  WHILE d^[dIdx] <> 0C DO
  137.    INC(dIdx);
  138.  END;
  139.  sIdx := 0;
  140.  REPEAT
  141.    c := s^[sIdx];
  142.    d^[dIdx] := c;
  143.    INC(sIdx);
  144.    INC(dIdx);
  145.  UNTIL c = 0C;
  146. END strcat;
  147.  
  148. (*---------------------------------------------------------------------------*)
  149.  
  150. PROCEDURE strncat ((* EIN/ -- *) dst : StrPtr;
  151.                    (* EIN/ -- *) src : StrPtr;
  152.                    (* EIN/ -- *) len : sizeT  );
  153. (*T*)
  154. VAR __REG__ dIdx : StrRange;
  155.     __REG__ sIdx : StrRange;
  156.     __REG__ c    : CHAR;
  157.     __REG__ d    : StrPtr;
  158.     __REG__ s    : StrPtr;
  159.     __REG__ l    : StrRange;
  160.  
  161. BEGIN
  162.  d := dst;
  163.  s := src;
  164.  l := VAL(StrRange,len);
  165.  IF (d = NULL) OR (s = NULL) OR (l = 0) THEN
  166.    RETURN;
  167.  END;
  168.  dIdx := 0;
  169.  WHILE d^[dIdx] <> 0C DO
  170.    INC(dIdx);
  171.  END;
  172.  sIdx := 0;
  173.  REPEAT
  174.    c := s^[sIdx];
  175.    d^[dIdx] := c;
  176.    INC(sIdx);
  177.    INC(dIdx);
  178.    DEC(l);
  179.  UNTIL (c = 0C) OR (l = 0);
  180.  IF c <> 0C THEN
  181.    d^[dIdx] := 0C;
  182.  END;
  183. END strncat;
  184.  
  185. (*---------------------------------------------------------------------------*)
  186.  
  187. PROCEDURE strcmp ((* EIN/ -- *) str1 : StrPtr;
  188.                   (* EIN/ -- *) str2 : StrPtr ): INTEGER;
  189. (*T*)
  190. VAR __REG__ idx : StrRange;
  191.     __REG__ c   : CHAR;
  192.     __REG__ s1  : StrPtr;
  193.     __REG__ s2  : StrPtr;
  194.  
  195. BEGIN
  196.  s1 := str1;
  197.  s2 := str2;
  198.  IF s1 = NULL THEN
  199.    IF s2 = NULL THEN
  200.      RETURN(0);
  201.    ELSE
  202.      RETURN(-1);
  203.    END;
  204.  ELSIF s2 = NULL THEN
  205.    RETURN(1);
  206.  END;
  207.  
  208.  idx := 0;
  209.  LOOP
  210.    c := s1^[idx];
  211.    IF c <> s2^[idx] THEN
  212.      IF c < s2^[idx] THEN
  213.        RETURN(-1);
  214.      ELSE
  215.        RETURN(1);
  216.      END;
  217.    ELSIF c = 0C THEN
  218.      RETURN(0);
  219.    END;
  220.    INC(idx);
  221.  END;
  222. END strcmp;
  223.  
  224. (*---------------------------------------------------------------------------*)
  225.  
  226. PROCEDURE strncmp ((* EIN/ -- *) str1  : StrPtr;
  227.                    (* EIN/ -- *) str2  : StrPtr;
  228.                    (* EIN/ -- *) len   : sizeT  ): INTEGER;
  229. (*T*)
  230. VAR __REG__ idx : StrRange;
  231.     __REG__ c   : CHAR;
  232.     __REG__ s1  : StrPtr;
  233.     __REG__ s2  : StrPtr;
  234.     __REG__ l   : StrRange;
  235.  
  236. BEGIN
  237.  s1 := str1;
  238.  s2 := str2;
  239.  l  := VAL(StrRange,len);
  240.  IF s1 = NULL THEN
  241.    IF s2 = NULL THEN
  242.      RETURN(0);
  243.    ELSE
  244.      RETURN(-1);
  245.    END;
  246.  ELSIF s2 = NULL THEN
  247.    RETURN(1);
  248.  END;
  249.  IF l = 0 THEN
  250.    RETURN(0);
  251.  END;
  252.  
  253.  idx := 0;
  254.  REPEAT
  255.    c := s1^[idx];
  256.    IF c <> s2^[idx] THEN
  257.      IF c < s2^[idx] THEN
  258.        RETURN(-1);
  259.      ELSE
  260.        RETURN(1);
  261.      END;
  262.    ELSIF c = 0C THEN
  263.      RETURN(0);
  264.    END;
  265.    INC(idx);
  266.    DEC(l);
  267.  UNTIL l = 0;
  268.  RETURN(0);
  269. END strncmp;
  270.  
  271. (*---------------------------------------------------------------------------*)
  272.  
  273. PROCEDURE strchr ((* EIN/ -- *) s : StrPtr;
  274.                   (* EIN/ -- *) c : CHAR   ): StrPtr;
  275. (*T*)
  276. VAR __REG__ idx : StrRange;
  277.     __REG__ ptr : StrPtr;
  278.     __REG__ ch  : CHAR;
  279.  
  280. BEGIN
  281.  ptr := s;
  282.  IF ptr = NULL THEN
  283.    RETURN(NULL);
  284.  END;
  285.  idx := 0;
  286.  LOOP
  287.    ch := ptr^[idx];
  288.    IF ch = c THEN
  289.      RETURN(CAST(StrPtr,ADR(ptr^[idx])));
  290.    ELSIF ch = 0C THEN
  291.      RETURN(NULL);
  292.    END;
  293.    INC(idx);
  294.  END;
  295. END strchr;
  296.  
  297. (*---------------------------------------------------------------------------*)
  298.  
  299. PROCEDURE strrchr ((* EIN/ -- *) s : StrPtr;
  300.                    (* EIN/ -- *) c : CHAR   ): StrPtr;
  301. (*T*)
  302. VAR __REG__ idx : StrRange;
  303.     __REG__ ptr : StrPtr;
  304.     __REG__ tmp : SIGNEDWORD;
  305.     __REG__ ch  : CHAR;
  306.  
  307. BEGIN
  308.  ptr := s;
  309.  IF ptr = NULL THEN
  310.    RETURN(NULL);
  311.  END;
  312.  tmp := -1;
  313.  idx := 0;
  314.  LOOP
  315.    ch := ptr^[idx];
  316.    IF ch = 0C THEN
  317.      IF c = 0C THEN
  318.        RETURN(CAST(StrPtr,ADR(ptr^[idx])));
  319.      ELSIF tmp = -1 THEN
  320.        RETURN(NULL);
  321.      ELSE
  322.        RETURN(CAST(StrPtr,ADR(ptr^[tmp])));
  323.      END;
  324.    END;
  325.    IF ch = c THEN
  326.      tmp := VAL(SIGNEDWORD,idx);
  327.    END;
  328.    INC(idx);
  329.  END;
  330. END strrchr;
  331.  
  332. (*---------------------------------------------------------------------------*)
  333.  
  334. PROCEDURE strstr ((* EIN/ -- *) str : StrPtr;
  335.                   (* EIN/ -- *) pat : StrPtr ): StrPtr;
  336. (*T*)
  337. VAR __REG__ pLen : StrRange;
  338.     __REG__ sLen : StrRange;
  339.     __REG__ pIdx : StrRange;
  340.     __REG__ sIdx : StrRange;
  341.     __REG__ s    : StrPtr;
  342.     __REG__ p    : StrPtr;
  343.  
  344. BEGIN
  345.  s := str;
  346.  p := pat;
  347.  IF (s = NULL) OR (p = NULL) THEN
  348.    RETURN(NULL);
  349.  END;
  350.  pLen := 0;
  351.  WHILE p^[pLen] <> 0C DO
  352.    INC(pLen);
  353.  END;
  354.  sLen := 0;
  355.  WHILE s^[sLen] <> 0C DO
  356.    INC(sLen);
  357.  END;
  358.  IF pLen = 0 THEN
  359.    RETURN(CAST(StrPtr,ADR(s^[sLen])));
  360.  ELSIF pLen > sLen THEN
  361.    RETURN(NULL);
  362.  END;
  363.  
  364.  DEC(sLen, pLen);
  365.  sIdx := 0;
  366.  LOOP
  367.    pIdx := 0;
  368.    WHILE (pIdx < pLen) AND (s^[sIdx] = p^[pIdx]) DO
  369.      INC(sIdx);
  370.      INC(pIdx);
  371.    END;
  372.    DEC(sIdx, pIdx);
  373.  
  374.    IF pIdx = pLen THEN
  375.      RETURN(CAST(StrPtr,ADR(s^[sIdx])));
  376.    ELSIF sLen = 0 THEN
  377.      RETURN(NULL);
  378.    END;
  379.  
  380.    INC(sIdx);
  381.    DEC(sLen);
  382.  END;
  383. END strstr;
  384.  
  385. (*---------------------------------------------------------------------------*)
  386.  
  387. PROCEDURE strpbrk ((* EIN/ -- *) str : StrPtr;
  388.                    (* EIN/ -- *) brk : StrPtr ): StrPtr;
  389. (*T*)
  390. VAR __REG__ bIdx : StrRange;
  391.     __REG__ bLen : StrRange;
  392.     __REG__ sIdx : StrRange;
  393.     __REG__ c    : CHAR;
  394.     __REG__ b    : StrPtr;
  395.     __REG__ s    : StrPtr;
  396.  
  397. BEGIN
  398.  s := str;
  399.  b := brk;
  400.  IF (s = NULL) OR (b = NULL) THEN
  401.    RETURN(NULL);
  402.  END;
  403.  bLen := VAL(StrRange,strlen(b));
  404.  sIdx := 0;
  405.  WHILE s^[sIdx] <> 0C DO
  406.    c    := s^[sIdx];
  407.    bIdx := 0;
  408.    WHILE (bIdx < bLen) AND (b^[bIdx] <> c) DO
  409.      INC(bIdx);
  410.    END;
  411.    IF bIdx < bLen THEN
  412.      RETURN(CAST(StrPtr,ADR(s^[sIdx])));
  413.    END;
  414.    INC(sIdx);
  415.  END;
  416.  RETURN(NULL);
  417. END strpbrk;
  418.  
  419. (*---------------------------------------------------------------------------*)
  420.  
  421. PROCEDURE strerror ((* EIN/ -- *)     errnum : INTEGER;
  422.                     (* -- /AUS *) VAR errstr : ARRAY OF CHAR );
  423. (*T*)
  424. VAR text : ARRAY [0..40] OF CHAR;
  425.     sIdx : UNSIGNEDWORD;
  426.     dIdx : UNSIGNEDWORD;
  427.  
  428. BEGIN
  429.  CASE errnum OF
  430.    e.eOK     : text := "OK";
  431.   |e.eRROR   : text := "error";
  432.   |e.eDRVNR  : text := "device not ready";
  433.   |e.eUNCMD  : text := "unknown command";
  434.   |e.eCRC    : text := "crc error";
  435.   |e.eBADRQ  : text := "bad request";
  436.   |e.eSEEK   : text := "seek error";
  437.   |e.eMEDIA  : text := "unknown media";
  438.   |e.eSECNF  : text := "sector not found";
  439.   |e.ePAPER  : text := "out of paper";
  440.   |e.eWRITF  : text := "write failure";
  441.   |e.eREADF  : text := "read failure";
  442.   |e.eGENRL  : text := "general error";
  443.   |e.eWRPRO  : text := "write protected";
  444.   |e.eCHNG   : text := "media changed";
  445.   |e.eUNDEV  : text := "unknown device";
  446.   |e.eBADSF  : text := "bad sectors found";
  447.   |e.eOTHER  : text := "another disk";
  448.  
  449.   |e.eINSERT : text := "insert media";
  450.   |e.eDVNRSP : text := "device not responding";
  451.  
  452.   |e.eINVFN  : text := "invalid function number";
  453.   |e.eFILNF  : text := "file not found";
  454.   |e.ePTHNF  : text := "path not found";
  455.   |e.eNHNDL  : text := "no more handles";
  456.   |e.eACCDN  : text := "access denied";
  457.   |e.eIHNDL  : text := "invalid handle";
  458.   |e.eNSMEM  : text := "out of memory";
  459.   |e.eIMBA   : text := "invalid memory block";
  460.   |e.eDRIVE  : text := "invalid drive";
  461.   |e.eNSAME  : text := "different drives";
  462.   |e.eNMFIL  : text := "no more files";
  463.  
  464.   |e.eLOCKED : text := "file locked";
  465.   |e.eNSLOCK : text := "invalid lock";
  466.  
  467.   |e.eRANGE  : text := "range error";
  468.   |e.eINTRN  : text := "internal error";
  469.   |e.ePLFMT  : text := "not executable";
  470.   |e.eGSBF   : text := "memory block growth failure";
  471.  
  472.   |e.E2BIG   : text := "argument list too long";
  473.   |e.EAGAIN  : text := "try again";
  474.   |e.EBUSY   : text := "resource unavailable";
  475.   |e.EDEADLK : text := "deadlock would result";
  476.   |e.EDOM    : text := "domain error";
  477.   |e.EEXIST  : text := "file exists";
  478.   |e.EFBIG   : text := "file too large";
  479.   |e.EINTR   : text := "interrupted by signal";
  480.   |e.EINVAL  : text := "invalid argument";
  481.   |e.EISDIR  : text := "is a directory";
  482.   |e.EMLINK  : text := "too many links";
  483.   |e.ENAMETOOLONG : text := "filename too long";
  484.   |e.ENOLCK  : text := "no locks available";
  485.   |e.ENOSPC  : text := "no space left on device";
  486.   |e.ENOTEMPTY : text := "directory not empty";
  487.   |e.ENOTTY  : text := "wrong i/o control op";
  488.   |e.EPIPE   : text := "broken pipe";
  489.   |e.ERANGE  : text := "result too large";
  490.   |e.ESPIPE  : text := "invalid seek";
  491.   |e.ELOOP   : text := "too many symbolic links";
  492.  ELSE
  493.              text := "unknown error";
  494.  END;
  495.  dIdx := 0;
  496.  sIdx := 0;
  497.  WHILE (dIdx <= VAL(UNSIGNEDWORD,HIGH(errstr))) AND (text[sIdx] <> EOS) DO
  498.    errstr[dIdx] := text[sIdx];
  499.    INC(dIdx);
  500.    INC(sIdx);
  501.  END;
  502.  IF dIdx <= VAL(UNSIGNEDWORD,HIGH(errstr)) THEN
  503.    errstr[dIdx] := EOS;
  504.  END;
  505. END strerror;
  506.  
  507. (*---------------------------------------------------------------------------*)
  508.  
  509. PROCEDURE AssignM2ToC ((* EIN/ -- *) REF strM2 : ARRAY OF CHAR;
  510.                        (* EIN/ -- *)     sizeC : StrRange;
  511.                        (* EIN/ -- *)     strC  : StrPtr        );
  512. (*T*)
  513. VAR __REG__ idx : StrRange;
  514.     __REG__ max : StrRange;
  515.     __REG__ ptr : StrPtr;
  516.  
  517. BEGIN
  518.  ptr := strC;
  519.  IF (ptr = NULL) OR (sizeC = 0) THEN
  520.    RETURN;
  521.  END;
  522.  
  523.  IF VAL(StrRange,HIGH(strM2)) < sizeC THEN
  524.    max := VAL(StrRange,HIGH(strM2));
  525.  ELSE
  526.    max := sizeC - 1;
  527.  END;
  528.  idx := 0;
  529.  WHILE (idx <= max) AND (strM2[idx] <> EOS) DO
  530.    ptr^[idx] := strM2[idx];
  531.    INC(idx);
  532.  END;
  533.  IF idx < sizeC THEN
  534.    ptr^[idx] := 0C;
  535.  END;
  536. END AssignM2ToC;
  537.  
  538. (*---------------------------------------------------------------------------*)
  539.  
  540. PROCEDURE AssignCToM2 ((* EIN/ -- *)     strC  : StrPtr;
  541.                        (* -- /AUS *) VAR strM2 : ARRAY OF CHAR );
  542. (*T*)
  543. VAR __REG__ idx : StrRange;
  544.     __REG__ c   : CHAR;
  545.     __REG__ ptr : StrPtr;
  546.  
  547. BEGIN
  548.  ptr := strC;
  549.  IF ptr = NULL THEN
  550.    strM2[0] := EOS;
  551.    RETURN;
  552.  END;
  553.  idx := 0;
  554.  c   := ptr^[0];
  555.  WHILE (idx <= VAL(StrRange,HIGH(strM2))) AND (c <> 0C) DO
  556.    strM2[idx] := c;
  557.    INC(idx);
  558.    c := ptr^[idx];
  559.  END;
  560.  IF idx <= VAL(StrRange,HIGH(strM2)) THEN
  561.    strM2[idx] := EOS;
  562.  END;
  563. END AssignCToM2;
  564.  
  565. (*===========================================================================*)
  566.  
  567. BEGIN (* cstr *)
  568.  null  := 0C;
  569.  nullP := CAST(StrPtr,ADR(null));
  570. END cstr.
  571.